home *** CD-ROM | disk | FTP | other *** search
/ Meeting Pearls 4 / Meeting Pearls Vol. IV (1996)(GTI - Schatztruhe)[!].iso / Pearls / dev / Language / CLisp / fd / read-fd.lsp < prev    next >
Lisp/Scheme  |  1996-08-12  |  6KB  |  152 lines
  1. (in-package "AFFI")
  2.  
  3. (export 'make-partial-affi-file)
  4.  
  5. (defun read-fd-directive (stream macro-char)
  6.   (declare (ignore macro-char)
  7.            (special *fd-readtable*))
  8.   (unless (eq *readtable* *fd-readtable*)
  9.     (error "Not the FD-readtable: ~S" *readtable*))
  10.   (let ((*package* (find-package "KEYWORD"))
  11.     (case (readtable-case *readtable*)))
  12.     (unwind-protect
  13.      (progn
  14.        (setf (readtable-case *readtable*) :upcase)
  15.        (read stream t nil t))
  16.       (setf (readtable-case *readtable*) case))))
  17.  
  18. ;;Problem: AmigaGuide uses * in OpenAmigaGuideA()
  19. ;; Replace it with attrs, see AutoDocs, which gives
  20. ;; APTR OpenAmigaGuideA( struct NewAmigaGuide *nag, struct TagItem *attrs )(a0/a1);
  21.  
  22. (defun make-fd-readtable (&optional (readtable-case :upcase))
  23.   (let ((readtable (copy-readtable nil)))
  24.     ;; , and / separate registers
  25.     (set-syntax-from-char #\, #\  readtable)
  26.     (set-syntax-from-char #\/ #\  readtable)
  27.     ;; * serves as a comment
  28.     (set-syntax-from-char #\* #\; readtable)
  29.     ;; ## introduces specials
  30.     (set-macro-character #\# #'read-fd-directive t readtable)
  31.     ;; we choose to preserve case for all function names
  32.     (setf (readtable-case readtable) readtable-case)
  33.     readtable))
  34.  
  35. ;; TODO maybe better read strings by preserving case, because output will look nicer?
  36.  
  37. (defvar *fd-readtable* (make-fd-readtable)) ;or :preserve
  38.  
  39. (defun read-from-fd (stream &optional (eof-error-p t))
  40.   (let* ((unique "EoF")
  41.      (read
  42.       ;; switch readtables very temporarily only
  43.       (let ((*readtable* *fd-readtable*))
  44.         (read stream nil unique))))
  45.     (if (eq read unique)
  46.     (if eof-error-p
  47.         (error "FD file ~S ended" stream)
  48.         :end)
  49.     read)))
  50.  
  51. ;; funinfo ist {(function . (offset . mask))}*
  52. (defun read-fd-functions (stream skip offset funinfo)
  53.   (let ((tag (read-from-fd stream nil)))
  54.     (etypecase tag
  55.       ;;(null (return-from read-fd-functions funinfo))
  56.       (keyword
  57.        (ecase tag
  58.          (:base (error "##base only allowed once: ~S"))
  59.          (:bias (setq offset (- (read-from-fd stream))))
  60.          (:public  (setq skip nil))
  61.          (:private (setq skip t))
  62.          (:end (return-from read-fd-functions funinfo)))
  63.        (read-fd-functions stream skip offset funinfo))
  64.       (symbol                           ;tag is function name
  65.        (let ((vars (read-from-fd stream))
  66.              (regs (read-from-fd stream)))
  67.          (unless (listp vars)
  68.            (error "No FFI variable names read from ~S: ~S" stream vars))
  69.          (unless (listp regs)
  70.            (error "No FFI register specification read from ~S: ~S" stream regs))
  71.          (read-fd-functions
  72.           stream skip (- offset 6)
  73.           (if skip funinfo
  74.           ;;TODO hashtable instead of alist
  75.               (cons (list* tag offset (calc-register-mask
  76.                        regs #'(lambda (reg sym) (string-equal reg (symbol-name sym)))))
  77.                 funinfo))))))))
  78.  
  79. ;;Problem: cia_lib.fd contains no library base
  80. ;; libinfo ist (basename . {(function offset . mask)}*)
  81. (defun parse-fd (name)
  82.   (with-open-file (file name :direction :input)
  83.     (let ((*package* '#.*package*))
  84.       (unless (eq (read-from-fd file) :base)
  85.         (error "FD file does not start with ##base: ~S" file))
  86.       (let ((library (read-from-fd file)))
  87.         (unless (symbolp library)
  88.           (error "Not a library base name: ~S in ~S" library file))
  89.         (cons (if (char= (schar (symbol-name library) 0) #\_) ;strip leading underscore
  90.           (intern (subseq (symbol-name library) 1))
  91.           library)
  92.               (read-fd-functions file nil -30 ()))))))
  93.  
  94. ;; Problem: current AFFI.D doesn't handle more than 8 args (uint32)
  95. ;; It's now 16 args (uint64)
  96. (defun show-large-masks (libinfos)
  97.   (dolist (libinfo libinfos)
  98.     ;;TODO hashtable instead of alist
  99.     (dolist (funinfo (rest libinfo))
  100.       (unless (typep (cddr funinfo) '(unsigned-byte 32))
  101.     (format t "~&;;Maybe too big mask for ~A in ~A~%" (car funinfo) (car libinfo))))))
  102. ;;Bignum mask for AddAppIconA in _WorkbenchBase
  103. ;;Bignum mask for CreateBehindHookLayer in _LayersBase
  104. ;;Bignum mask for CreateUpfrontHookLayer in _LayersBase
  105. ;;Bignum mask for CreateBehindLayer in _LayersBase
  106. ;;Bignum mask for CreateUpfrontLayer in _LayersBase
  107. ;;Bignum mask for ScrollWindowRaster in _IntuitionBase
  108. ;;Bignum mask for NewModifyProp in _IntuitionBase
  109. ;;Bignum mask for AutoRequest in _IntuitionBase
  110. ;;Bignum mask for ModifyProp in _IntuitionBase
  111. ;;Bignum mask for WriteChunkyPixels in _GfxBase
  112. ;;Bignum mask for ScrollRasterBF in _GfxBase
  113. ;;Bignum mask for WritePixelArray8 in _GfxBase
  114. ;;Bignum mask for ReadPixelArray8 in _GfxBase
  115. ;;Bignum mask for TextFit in _GfxBase
  116. ;;Bignum mask for BltMaskBitMapRastPort in _GfxBase
  117. ;;Bignum mask for BltBitMapRastPort in _GfxBase
  118. ;;Bignum mask for ClipBlit in _GfxBase
  119. ;;Bignum mask for ScrollRaster in _GfxBase
  120. ;;Bignum mask for BltPattern in _GfxBase
  121. ;;Bignum mask for BltTemplate in _GfxBase
  122. ;;Bignum mask for BltBitMap in _GfxBase
  123. ;;Bignum mask for DoPkt in _DOSBase
  124.  
  125. (defun make-partial-affi-file (name) ; name like "graphics.library"
  126.   ;; writes file to current directory, reads from FD:<base>_lib.fd
  127.   (let ((fdlibinfo (parse-fd (format () "FD:~A_lib.fd" (pathname-name name))))
  128.     (*package* '#.*package*))
  129.     (with-open-file (stream
  130.              (namestring (make-pathname :type "affi" :defaults name))
  131.              :direction :output
  132.              :if-exists :error)    ;at least for now
  133.       (princ "(in-package \"AFFI\")" stream)(terpri stream)
  134.       (format stream "(declare-library-base :~A ~S)~%" (car fdlibinfo) name)
  135.       (format stream "(format *error-output* \"~~&;;; Warning: Please adapt the prototypes for ~~S manually!~~%\" ~S)~%~%" name)
  136.       (dolist (ffinfo (nreverse (rest fdlibinfo)))
  137.     ;; the current implementation of AFFI.D is limited:
  138.     (unless (typep (cddr ffinfo) '(unsigned-byte 32))
  139.       (princ ";; This mask may be too large for AFFI:" stream)
  140.       (terpri stream))
  141.     (format stream ";(defflibfun '~S '~S ~D #x~X '*"
  142.         (car ffinfo)        ;Function
  143.         (car fdlibinfo)        ;Library
  144.         (cadr ffinfo)        ;Offset
  145.         (cddr ffinfo))        ;Mask
  146.     ;; Here we abuse the knowledge that AFFI.D:reg_coding is 4:
  147.     (dotimes (i (ceiling (integer-length (cddr ffinfo)) 4))
  148.       (princ " '*" stream))
  149.     (princ ")" stream)(terpri stream))
  150.       (format stream "~%(provide ~S)~%" name)
  151.       (pathname stream))))
  152.